perm filename DREDIT.F4[MSS,LCS]1 blob sn#052366 filedate 1974-01-08 generic text, type T, neo UTF8
00100		SUBROUTINE DREDIT
00200		COMMON/ED/K,NEXT,NN,NX,NY,J
00300		COMMON /RZ/RSZ,IPLT,RJB,CENTR
00400		COMMON /RC/MCLEF(200),IST(4000),MFILL(200)
00500		COMMON/ZN/SCLEF(200,2),N
00600		COMMON/LL/LL
00700		COMMON/JJJ/JJJ
00800		EQUIVALENCE(M,SCLEF(1,2)),(KK,SCLEF(1,1))
00900		NEXTX=NEXT-1
01000		IF(M)GO TO 20
01100	CC	A=STPT(SCLEF(NEXTX,1),RJB)
01200	CC	B=STPT(SCLEF(NEXTX,2),CENTR)
01300	CC	TYPE 4,NEXTX,A,B
01400		J=MCLEF(1)
01500	20	IF(K.EQ.'D')GO TO 1
01600	C  MOVE CURSOR TO INSERT POINT, TYPE CR.
01700	9	FORMAT(' SET POINT ',$)
01800		IF(JJJ.AND.JJK)GO TO 131
01900	C  FOR CONTINUING RELATIVE CHANGE
02000		IF(JJJ.EQ.0)JJK=0
02100	5	TYPE 9
02200		ACCEPT 3,L
02300		IF(L.EQ.'B'.OR.L.EQ.'N')RETURN
02400	C N OR B=BACKUP, J=INSERT OR ALTER TO JUMP, C=ALTER JUMP TO CONT.
02500		IF(L.EQ.' ')GO TO 12
02600		REREAD 33,ML,MLA
02700		IF(JJJ)JJK=-1
02800	C TO SET POINT BY NUM(NOT FOR FILLER)	NOT NOW IN!
02900	131	IF(M.GE.0)CALL UNPACK(NEXTX,NX,NY,MCLEF)
03000		IF(M)CALL UNPACK(NEXTX,NX,NY,MFILL)
03100	C  FOR RELATIVE POS. CHANGE
03200		X=NX+ML
03300		Y=NY+MLA
03400		GO TO 13
03500	12	CALL RDCUR(NX,NY)
03600	130	X=STPT(FLOAT(NX),RJB)
03700		Y=STPT(FLOAT(NY),CENTR)
03800	13	NX=GTPT(X,RJB)
03900		NY=GTPT(Y,CENTR)
04000		CALL SETCUR(NX,NY,0)
04100		IF(K.EQ.0)GO TO 14
04200		NT=NEXT
04300		L=NT
04400		IF(M)L=L-1
04500	C FOR FILL-EDIT
04600	40	FORMAT(' POINT OK? (Y,N,B,J OR C) ',$)
04700		TYPE 4,L,X,Y
04800		TYPE 40
04900		ACCEPT 3,L
05000		IF(L.EQ.'N')GO TO 5
05100		IF(K.NE.'A')GO TO 8
05200		NT=NEXTX
05300		GO TO 7
05400	11	FORMAT(I3,')',2I6,1X$)
05500	8	IF(M)GO TO 7
05600		TYPE 19
05700		ACCEPT 3,L
05800		IF(L.EQ.'B')RETURN
05900		A=X
06000		B=Y
06100		K=0
06200		GO TO 12
06300	C NOW ASSUMES → IF NO ← POINT FOUND
06400	14	IF(NX.EQ.SCLEF(NT-2,1).AND.NY.EQ.SCLEF(NT-2,2))NT=NT-1
06500	15	X=A
06600		Y=B
06700		J=J+1
06800		DO 6 L=J,NT+1,-1
06900	6	MCLEF(L)=MCLEF(L-1)
07000	7	LL=0
07100		NX=X
07200		NY=Y
07300		IF(M.EQ.-1)RETURN
07400	C  -1=GO BACK TO FILL-EDITOR
07500		IF((MCLEF(NT).GT.100000000.AND.L.NE.'C').OR.L.EQ.'J')LL=3
07600		K=MCLEF(NT)
07700		CALL REPACK(NT,NX,NY,MCLEF)
07800		IF(MFILL(1).NE.0)CALL FILTOO(MCLEF(NT))
07900		GO TO 100
08000	19	FORMAT(' OTHER POINT? ',$)
08100	3	FORMAT(A1)
08200	33	FORMAT(2I)
08300	4	FORMAT(I4,')',2F6.0)
08400	C  NT IS FOR INSERTS
08450	1	IF(J-NEXT)RETURN
08500		DO 10 L=NEXT,J+1
08600	10	MCLEF(L-1)=MCLEF(L)
08700		J=J-1
08800	100	MCLEF(1)=J
08900		KK=0
09000		IF(MCLEF(2).LT.100000000)MCLEF(2)=MCLEF(2)+100000000
09100		CALL DPYSET(1,IST,4000)
09200		CALL DPYBRT(5)
09300		KK=1
09400		CALL RDRAW(2,MCLEF(1),MCLEF,RJB,CENTR)
09500		RETURN
09600	2	CALL RDCUR(NX,NY)
09700		END
09800	
09900	C*******************************************************
10000		FUNCTION STPT(A,X)
10100		COMMON /RZ/RSZ,IPLT,RJB,CENTR
10200		R=.5
10300		Q=A/RSZ-X
10400		IF(Q)R=-R
10500		STPT=IFIX(Q+R)
10600		RETURN
10700		END
10800	
10900		FUNCTION GTPT(A,X)
11000		COMMON /RZ/RSZ,IPLT,RJB,CENTR
11100		GTPT=(A+X)*RSZ
11200		RETURN
11300		END
11400	
11500	
11600		SUBROUTINE FILTOO(M)
11700		COMMON /RC/MCLEF(200),IST(4000),MFILL(200)
11800		COMMON/ED/K,NEXT,NN,NX,NY,J
11850		I=M
11900		IF(I.GT.100000000)I=I-100000000
12000		DO 1 L=2,MFILL(1)
12100	1	IF(MFILL(L).EQ.K)MFILL(L)=I
12200	C  THIS COULD GET CAUGHT ON A WDCNT**********(USE IP(N)?)
12300		RETURN
12400		END